home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
msortp.zip
/
MSORTP.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-02-05
|
44KB
|
1,480 lines
{*********************************************************}
{* MSORTP.PAS 5.40 *}
{* Copyright (c) TurboPower Software 1993. *}
{* All rights reserved. *}
{*********************************************************}
{$F-,V-,B-,S-,I-,R-,X+,A+}
{$IFDEF Ver70}
{$Q-}
{$ENDIF}
unit MSortP;
{-Merge sort unit. Requires TPW or BP7 (rmode, pmode, Windows)}
interface
uses
{$IFDEF Windows}
WinTypes,
WinProcs,
{$ENDIF}
{$IFDEF DPMI}
WinApi,
{$ENDIF}
Strings;
const
MinRecsPerRun = 4; {Minimum number of records in run buffer}
MergeOrder = 5; {Input files used at a time during merge, >=2, <=10}
MaxSelectors = 256; {Maximum number of selectors allocated}
SwapThreshold = 64; {RecLen at least this big causes pointer swap}
MedianThreshold = 16; {Sort size where median-of-three is used}
type
ElementIOProc = procedure;
ElementCompareFunc = function (var X, Y) : Boolean;
MergeNameFunc = function (Dest : PChar; MergeNum : Word) : PChar;
MergeInfoRec =
record {Record returned by MergeInfo}
SortStatus : Word; {Predicted status of sort, assuming disk ok}
MergeFiles : Word; {Total number of merge files created}
MergeHandles : Word; {Maximum file handles used}
MergePhases : Word; {Number of merge phases}
MaxDiskSpace : LongInt; {Maximum peak disk space used}
HeapUsed : LongInt; {Heap space actually used}
SelectorCount: Word; {Number of selectors allocated}
RecsPerSel : Word; {Records stored in each selector}
end;
function MergeSort(MaxHeapToUse : LongInt;
RecLen : Word;
SendToSortEngine : ElementIOProc;
Less : ElementCompareFunc;
GetFromSortEngine : ElementIOProc;
MergeName : MergeNameFunc) : Word;
{-Sorts elements of size RecLen. Uses no more than MaxHeapToUse
bytes of heap space. Elements are passed into MergeSort by the
user-defined SendToSortEngine routine. Elements are compared by
the user-defined Less routine. Sorted elements are passed back
to the program by the user-defined GetFromSortEngine routine.
When merge files must be used, the name and location of each
merge file is determined by the user-defined MergeName routine.
MergeSort returns a status code:
0 success
1 user abort
8 insufficient memory to sort
106 invalid input parameter
(RecLen zero, MaxHeapToUse too small)
204 invalid pointer returned by GlobalLock, or
SelectorInc <> 8
213 no elements available to sort
214 more than 65535 merge files
else DOS or Turbo Pascal error code}
function PutElement(var X) : Boolean;
{-Submits an element to the sort system. Returns True if the record
is successfully submitted.}
function GetElement(var X) : Boolean;
{-Returns next record in sorted order. Returns True while there are
more records to return. When it returns False, X is uninitialized.}
function DefaultMergeName(Dest : PChar; MergeNum : Word) : PChar;
{-Returns a default name for each merge file (SORnnnnn.TMP)}
procedure AbortSort;
{-Call this routine from Less, SendToSortEngine, or GetFromSortEngine
to abort the sort. The Less function must always return False
if it calls AbortSort.}
function OptimumHeapToUse(RecLen : Word; NumRecs : LongInt) : LongInt;
{-Returns the optimum amount of heap space to sort NumRecs records
of RecLen bytes each. Less heap space causes merging; more heap
space is partially unused.}
function MinimumHeapToUse(RecLen : Word) : LongInt;
{-Returns the absolute minimum heap that allows MergeSort to succeed}
procedure MergeInfo(MaxHeapToUse : LongInt;
RecLen : Word;
NumRecs : LongInt;
var MI : MergeInfoRec);
{-Predicts status and resource usage of a merge sort. See
MergeInfoRec above for the information returned. Returns
MI.MaxDiskSpace = -1 in the rare case where disk space analysis
cannot be performed.}
{==================================================================}
implementation
type
OS =
record {Convenient typecast}
O : Word;
S : Word;
end;
PointerPtr = ^Pointer; {Pointer to pointer}
ElementPtrFunc =
function (ElNum : LongInt) : Pointer; {Return address of given element}
SwapElementProc =
procedure (Pl, Pr : LongInt); {Swap two elements}
MergeWordArray =
array[1..MergeOrder] of Word; {Handles of open merge files}
MergePtrArray =
array[1..MergeOrder] of Pointer; {Used for managing head elements}
SelectorArray =
array[0..MaxSelectors-1] of Word; {Used for managing the run buffer}
PathArray =
array[0..79] of Char; {Used for buffering a pathname}
var
SortStatus : Word; {Current status of sort}
TotalCount : LongInt; {Total elements sorted}
{Variables related to memory management}
Selectors : SelectorArray; {Selectors for global work area}
SelectorCount : Word; {Number of selectors allocated}
DSelectorCount : Word; {Number of selectors for run data}
RecsPerSel : Word; {Number of records mapped by one selector}
RecsShr : Word; {SHR count corresponding to RecsPerSel}
RecsMask : Word; {AND mask corresponding to RecsPerSel}
RecordLen : Word; {Bytes in each data record}
RecordLenAlloc : Word; {Bytes in each data record buffer}
SwapPointers : WordBool; {True when swapping pointers}
{Variables related to run sorting}
AllocatedRecs : LongInt; {Total records allocated in global buffer}
RunCapacity : LongInt; {Capacity (in records) of run buffer}
RunCount : LongInt; {Current number of records in run buffer}
RunElement : LongInt; {Last run element passed back to user}
PivotPtr : Pointer; {Pointer to pivot record}
SwapPtr : Pointer; {Pointer to record swap area}
LessF : ElementCompareFunc; {User less function}
ElementPtrF : ElementPtrFunc; {Element pointer function}
SwapElementP : SwapElementProc; {Swap element procedure}
{Variables related to merging}
MergeNameF : MergeNameFunc; {User merge filename function}
MergeFileCount : Word; {Number of merge files created}
MergeFileMerged : Word; {Index of last merge file merged}
MergeOpenCount : Word; {Count of open merge files}
MergeBufSize : Word; {Usable bytes in merge buffer}
MergeFileNumber : MergeWordArray; {File number of each open merge file}
MergeFiles : MergeWordArray; {File handles for merge files}
MergeSelectors : MergeWordArray; {Selectors for each merge buffer}
MergeBytesLoaded : MergeWordArray; {Count of bytes in each merge buffer}
MergeBytesUsed : MergeWordArray; {Bytes used in each merge buffer}
MergePtrs : MergePtrArray; {Current head elements in each merge buffer}
OutFile : Word; {Output file handle}
OutSelector : Word; {Selector for output buffer}
OutBytesUsed : Word; {Number of bytes in output buffer}
{$DEFINE UseAsm} {Undefine only for testing}
{$IFNDEF DPMI}
{$IFNDEF Windows}
{Emulate a couple of memory allocation functions. These
work only if Bytes < 65511, which is always true here.
Requires the heap manager of TP6 or later.}
const
gmem_Moveable = $0002; { Allocate moveable memory }
type
THandle = Word;
function HeapFunc(Size : Word) : Integer; far;
{-Return nil pointer if insufficient memory}
begin
if Size <> 0 then
HeapFunc := 1;
end;
function GlobalAlloc(Flags : Word; Bytes : Longint) : THandle;
var
Alloc : Longint;
P : Pointer;
SaveHeapError : Pointer;
begin
Alloc := Bytes+16;
if Alloc > 65527 then
GlobalAlloc := 0
else begin
SaveHeapError := HeapError;
HeapError := @HeapFunc;
GetMem(P, Alloc);
if P = nil then
GlobalAlloc := 0
else begin
GlobalAlloc := OS(P).S+1;
Pointer(Ptr(OS(P).S, 8)^) := P;
LongInt(Ptr(OS(P).S, 12)^) := Alloc;
end;
HeapError := SaveHeapError;
end;
end;
function GlobalFree(H : THandle) : THandle;
var
Alloc : Longint;
P : Pointer;
begin
if H <> 0 then begin
dec(H);
P := Pointer(Ptr(H, 8)^);
Alloc := LongInt(Ptr(H, 12)^);
FreeMem(P, Alloc);
end;
GlobalFree := 0;
end;
{$ENDIF}
{$ENDIF}
function CreateFile(FName : PChar; var Handle : Word) : Word; assembler;
{-Create a file, returning status code and open handle}
asm
push ds
lds dx,FName
mov ah,$3C
xor cx,cx
int $21
jc @Done
les di,Handle
mov es:[di],ax
xor ax,ax
@Done:
pop ds
end;
function OpenFile(FName : PChar; var Handle : Word) : Word; assembler;
{-Open file read-only, returning status code and open handle}
asm
push ds
lds dx,FName
mov ax,$3D00 {read only}
int $21
jc @Done
les di,Handle
mov es:[di],ax
xor ax,ax
@Done:
pop ds
end;
function BlockWriteFile(Handle : Word; var Buf; BufLen : Word) : Word; assembler;
{-Write buffer to file, returning status}
asm
push ds
mov bx,Handle
mov cx,BufLen
lds dx,Buf
mov ah,$40
int $21
jc @Done
cmp ax,cx
mov ax,101 {disk full}
jne @Done
xor ax,ax
@Done:
pop ds
end;
function BlockReadFile(Handle : Word; var Buf;
BufLen : Word; var Len : Word) : Word; assembler;
{-Read buffer from file, returning status and bytes read}
asm
push ds
mov bx,Handle
mov cx,BufLen
lds dx,Buf
mov ah,$3F
int $21
jc @Done
les di,Len
mov es:[di],ax
xor ax,ax
@Done:
pop ds
end;
function CloseFile(Handle : Word) : Word; assembler;
{-Close file, returning status}
asm
mov bx,Handle
mov ah,$3E
int $21
jc @Done
xor ax,ax
@Done:
end;
function DeleteFile(FName : PChar) : Word; assembler;
{-Delete closed file, returning status}
asm
push ds
lds dx,FName
mov ah,$41
int $21
jc @Done
xor ax,ax
@Done:
pop ds
end;
function ElementPtrDirect(ElNum : LongInt) : Pointer; far;
{-Return pointer to given element in the global buffer}
{$IFDEF UseAsm}
assembler;
asm
mov ax,word ptr ElNum
mov dx,word ptr ElNum+2
mov si,ax {Save low word of ElNum}
mov cl,byte ptr RecsShr
{The following stuff circumvents the use of a 32-bit shift}
cmp cl,8 {RecordLenAlloc > 256 bytes?}
jb @2 {Jump if so}
cmp cl,16 {RecordLenAlloc = 1 byte?}
jne @1 {Jump if not}
mov ax,dx {RecordLenAlloc = 1 byte}
jmp @3
@1: mov al,ah {RecordLenAlloc <= 256 bytes}
mov ah,dl
sub cl,8
@2: shr ax,cl
@3: shl ax,1 {ax = selector offset}
mov bx,ax {bx = offset into Selectors}
mov ax,RecsMask {ax = offset mask}
and ax,si {ax = OS(ElNum).O and RecsMask}
mul word ptr RecordLenAlloc {ax = data offset}
mov dx,word ptr Selectors[bx] {dx:ax = address}
end;
{$ELSE}
begin
ElementPtrDirect := Ptr(Selectors[ElNum shr byte(RecsShr)],
(OS(ElNum).O and RecsMask)*RecordLenAlloc);
end;
{$ENDIF}
function ElementPtrIndirect(ElNum : LongInt) : Pointer; far;
{-Return pointer to element, assuming that first four bytes
of buffer are another pointer}
{$IFDEF UseAsm}
assembler;
asm
mov ax,word ptr ElNum
mov dx,word ptr ElNum+2
mov si,ax
mov cl,byte ptr RecsShr
cmp cl,8
jb @2
cmp cl,16
jne @1
mov ax,dx
jmp @3
@1: mov al,ah
mov ah,dl
sub cl,8
@2: shr ax,cl
@3: shl ax,1
mov bx,ax
mov ax,RecsMask
and ax,si
mul word ptr RecordLenAlloc
mov di,ax
mov es,word ptr Selectors[bx]
les ax,es:[di]
mov dx,es
end;
{$ELSE}
begin
ElementPtrIndirect := PointerPtr(Ptr(Selectors[ElNum shr byte(RecsShr)],
(OS(ElNum).O and RecsMask)*RecordLenAlloc))^;
end;
{$ENDIF}
procedure MoveElement(SPtr, DPtr : Pointer); assembler;
{-Move one element into another. Assumes SPtr <> DPtr}
asm
mov dx,ds
mov cx,RecordLen
lds si,SPtr
les di,DPtr
cld
shr cx,1
rep movsw
rcl cx,1
rep movsb
mov ds,dx
end;
procedure SwapElementsDirect(Pl, Pr : LongInt); far;
{-Swap data of elements}
var
LPtr : Pointer;
RPtr : Pointer;
begin
LPtr := ElementPtrDirect(Pl);
RPtr := ElementPtrDirect(Pr);
MoveElement(LPtr, SwapPtr);
MoveElement(RPtr, LPtr);
MoveElement(SwapPtr, RPtr);
end;
procedure SwapElementPtrs(Pl, Pr : LongInt); far;
{-Swap element pointers}
{$IFDEF UseAsm}
assembler;
asm
push word ptr Pl+2
push word ptr Pl
call ElementPtrDirect
push dx {Save result}
push ax
push word ptr Pr+2
push word ptr Pr
call ElementPtrDirect
mov bx,ds
mov es,dx
mov di,ax {es:di -> RPtr}
pop si
pop ds {ds:si -> LPtr}
mov ax,es:[di]
mov dx,es:[di+2]
xchg ax,ds:[si]
xchg dx,ds:[si+2]
mov es:[di],ax
mov es:[di+2],dx
mov ds,bx
end;
{$ELSE}
var
LPtr : PointerPtr;
RPtr : PointerPtr;
TPtr : Pointer;
begin
LPtr := ElementPtrDirect(Pl);
RPtr := ElementPtrDirect(Pr);
TPtr := LPtr^;
LPtr^ := RPtr^;
RPtr^ := TPtr;
end;
{$ENDIF}
procedure QuickSort(L, R : LongInt);
{-Non-recursive in-memory quicksort}
const
StackSize = 32;
type
Stack = array[1..StackSize] of LongInt;
var
Pl : LongInt; {Left edge within partition}
Pr : LongInt; {Right edge within partition}
PartitionLen : LongInt; {Length of partition}
LPtr : Pointer; {Three elements used to find median}
MPtr : Pointer;
RPtr : Pointer;
StackP : Integer; {Stack pointer}
Lstack : Stack; {Pending partitions, left edge}
Rstack : Stack; {Pending partitions, right edge}
begin
{Initialize the stack}
StackP := 1;
Lstack[1] := L;
Rstack[1] := R;
{Repeatedly take top partition from stack}
repeat
{Pop the stack}
L := Lstack[StackP];
R := Rstack[StackP];
Dec(StackP);
{Sort current partition}
repeat
PartitionLen := R-L+1;
MPtr := ElementPtrF(L+(PartitionLen shr 1));
if PartitionLen >= MedianThreshold then begin
{Find median element of three, storing pointer in MPtr}
LPtr := ElementPtrF(L);
RPtr := ElementPtrF(R);
if LessF(LPtr^, MPtr^) then begin
if LessF(MPtr^, RPtr^) then
{MPtr is the pivot}
else if LessF(RPtr^, LPtr^) then
MPtr := LPtr
else
MPtr := RPtr;
end else if LessF(RPtr^, LPtr^) then begin
if LessF(MPtr^, RPtr^) then
MPtr := RPtr;
end else
MPtr := LPtr;
end;
{Save the pivot element}
MoveElement(MPtr, PivotPtr);
{Swap items in sort order around the pivot}
Pl := L;
Pr := R;
repeat
{$IFDEF UseAsm}
asm
@0: push word ptr Pl+2
push word ptr Pl
call dword ptr ElementPtrF
push dx
push ax
push word ptr PivotPtr+2
push word ptr PivotPtr
call dword ptr LessF
or al,al
jz @1
add word ptr Pl,1
adc word ptr Pl+2,0
jmp @0
@1: push word ptr Pr+2
push word ptr Pr
call dword ptr ElementPtrF
push word ptr PivotPtr+2
push word ptr PivotPtr
push dx
push ax
call dword ptr LessF
or al,al
jz @2
sub word ptr Pr,1
sbb word ptr Pr+2,0
jmp @1
@2: end;
{$ELSE}
while LessF(ElementPtrF(Pl)^, PivotPtr^) do
Inc(Pl);
while LessF(PivotPtr^, ElementPtrF(Pr)^) do
Dec(Pr);
{$ENDIF}
{Check for user abort}
if SortStatus <> 0 then
Exit;
if Pl = Pr then begin
{Reached the pivot}
Inc(Pl);
Dec(Pr);
end else if Pl < Pr then begin
{Swap elements around the pivot}
SwapElementP(Pl, Pr);
Inc(Pl);
Dec(Pr);
end;
until Pl > Pr;
{Decide which partition to sort next}
if (Pr-L) < (R-Pl) then begin
{Left partition is bigger}
if Pl < R then begin
{Stack the request for sorting right partition}
Inc(StackP);
Lstack[StackP] := Pl;
Rstack[StackP] := R;
end;
{Continue sorting left partition}
R := Pr;
end else begin
{Right partition is bigger}
if L < Pr then begin
{Stack the request for sorting left partition}
Inc(StackP);
Lstack[StackP] := L;
Rstack[StackP] := Pr;
end;
{Continue sorting right partition}
L := Pl;
end;
until L >= R;
until StackP <= 0;
end;
procedure CreateNewMergeFile(var Handle : Word);
{-Create a new merge file}
var
FName : PathArray;
begin
if MergeFileCount = 65535 then begin
{Too many merge files}
SortStatus := 214;
Exit;
end;
{Create new merge file}
inc(MergeFileCount);
SortStatus := CreateFile(MergeNameF(FName, MergeFileCount), Handle);
if SortStatus <> 0 then
dec(MergeFileCount);
end;
procedure FlushOutBuffer;
{-Write the merge output buffer to disk}
begin
if OutBytesUsed <> 0 then
SortStatus := BlockWriteFile(OutFile, Mem[OutSelector:0], OutBytesUsed);
end;
procedure StoreElement(ElPtr : Pointer);
{-Store element in the merge output buffer}
begin
if OutBytesUsed >= MergeBufSize then begin
FlushOutBuffer;
if SortStatus <> 0 then
Exit;
OutBytesUsed := 0;
end;
MoveElement(ElPtr, Ptr(OutSelector, OutBytesUsed));
inc(OutBytesUsed, RecordLen);
end;
procedure StoreNewMergeFile;
{-Create a new merge file and store run buffer to it}
label
ExitPoint;
var
SelNum : Word;
BytesLeft : LongInt;
BytesToWrite : LongInt;
ElNum : LongInt;
TempStatus : Word;
begin
{Create new merge file}
CreateNewMergeFile(OutFile);
if SortStatus <> 0 then
Exit;
if SwapPointers then begin
{Write the run buffer element by element using pointer indirection}
OutBytesUsed := 0;
OutSelector := Selectors[DSelectorCount];
for ElNum := 0 to RunCount-1 do begin
StoreElement(ElementPtrIndirect(ElNum));
if SortStatus <> 0 then
goto ExitPoint;
end;
FlushOutBuffer;
end else begin
{Write the run buffer by blocks to the merge file}
BytesLeft := RunCount*RecordLen;
BytesToWrite := MergeBufSize;
SelNum := 0;
while BytesLeft > 0 do begin
OutSelector := Selectors[SelNum];
if BytesLeft < BytesToWrite then
BytesToWrite := BytesLeft;
SortStatus := BlockWriteFile(OutFile, Mem[OutSelector:0], BytesToWrite);
if SortStatus <> 0 then
BytesLeft := 0
{Note: all merge files are deleted in MergeSort}
else begin
dec(BytesLeft, BytesToWrite);
inc(SelNum);
end;
end;
end;
ExitPoint:
{Close merge file}
TempStatus := CloseFile(OutFile);
if SortStatus = 0 then
SortStatus := TempStatus;
end;
procedure GetMergeElementPtr(M : Word);
{-Get pointer to next valid element of specified open merge file}
var
Len : Word;
TempStatus : Word;
FName : PathArray;
begin
if MergeBytesUsed[M] >= MergeBytesLoaded[M] then begin
{Try to load new data into buffer}
SortStatus := BlockReadFile(MergeFiles[M], Mem[MergeSelectors[M]:0],
MergeBufSize, Len);
if (SortStatus <> 0) or (Len < RecordLen) then begin
{Error reading file or end of file. Close and delete it}
TempStatus := CloseFile(MergeFiles[M]);
TempStatus := DeleteFile(MergeNameF(FName, MergeFileNumber[M]));
{Remove file from merge list}
if M <> MergeOpenCount then begin
MergeFileNumber[M] := MergeFileNumber[MergeOpenCount];
MergeFiles[M] := MergeFiles[MergeOpenCount];
MergeSelectors[M] := MergeSelectors[MergeOpenCount];
MergeBytesLoaded[M] := MergeBytesLoaded[MergeOpenCount];
MergeBytesUsed[M] := MergeBytesUsed[MergeOpenCount];
MergePtrs[M] := MergePtrs[MergeOpenCount];
end;
dec(MergeOpenCount);
Exit;
end;
MergeBytesLoaded[M] := Len;
MergeBytesUsed[M] := 0;
end;
OS(MergePtrs[M]).O := MergeBytesUsed[M];
inc(MergeBytesUsed[M], RecordLen);
end;
procedure OpenMergeFiles;
{-Open next group of merge files (up to MergeOrder of them)}
var
FName : PathArray;
begin
MergeOpenCount := 0;
while (MergeOpenCount < MergeOrder) and (MergeFileMerged < MergeFileCount) do begin
{MergeOpenCount counts the number of open merge files}
inc(MergeOpenCount);
{Open associated merge file}
inc(MergeFileMerged);
SortStatus := OpenFile(MergeNameF(FName, MergeFileMerged), MergeFiles[MergeOpenCount]);
if SortStatus <> 0 then begin
dec(MergeFileMerged);
dec(MergeOpenCount);
Exit;
end;
{File number of merge file}
MergeFileNumber[MergeOpenCount] := MergeFileMerged;
{Selector for merge file}
MergeSelectors[MergeOpenCount] := Selectors[MergeOpenCount-1];
{Number of bytes currently in merge buffer}
MergeBytesLoaded[MergeOpenCount] := 0;
{Number of bytes used in merge buffer}
MergeBytesUsed[MergeOpenCount] := 0;
{Save the segment of the merge pointer}
OS(MergePtrs[MergeOpenCount]).S := MergeSelectors[MergeOpenCount];
{Get the first element}
GetMergeElementPtr(MergeOpenCount);
if SortStatus <> 0 then
Exit;
end;
end;
function GetNextElementIndex : Word;
{-Return merge index of next element in sorted order, nil if error or none}
{$IFDEF UseAsm}
assembler;
var
MinElPtr : Pointer;
asm
{Get out fast if 0 or 1 merge files left open}
xor ax,ax
mov cx,MergeOpenCount
jcxz @3
inc ax
cmp cx,2
jb @3
{Assume first element is the least}
les di,dword ptr MergePtrs
mov word ptr MinElPtr,di
mov word ptr MinElPtr+2,es
mov bx,2
{Loop to find minimum element}
@1: push ax {save result}
push bx {save loop index}
shl bx,1
shl bx,1
les di,dword ptr MergePtrs[bx-4]
push es {save MergePtrs[M]}
push di
push es
push di
les di,MinElPtr
push es
push di
call dword ptr LessF
or al,al
pop di
pop es
pop bx
pop ax
jz @2
mov ax,bx
mov word ptr MinElPtr,di
mov word ptr MinElPtr+2,es
@2: inc bx
cmp bx,MergeOpenCount
jbe @1
@3:
end;
{$ELSE}
var
M : Word;
MinElPtr : Pointer;
begin
if MergeOpenCount = 0 then begin
{All merge streams are empty}
GetNextElementIndex := 0;
Exit;
end;
{Assume first element is the least}
MinElPtr := MergePtrs[1];
GetNextElementIndex := 1;
{Scan the other elements}
for M := 2 to MergeOpenCount do
if LessF(MergePtrs[M]^, MinElPtr^) then begin
GetNextElementIndex := M;
MinElPtr := MergePtrs[M];
end;
end;
{$ENDIF}
procedure MergeFileGroup;
{-Merge the opened merge files into the output}
var
NextElementIndex : Word;
TempStatus : Word;
Done : WordBool;
begin
Done := False;
repeat
{Find index of minimum element}
NextElementIndex := GetNextElementIndex;
if SortStatus <> 0 then
Done := True
else if NextElementIndex = 0 then
Done := True
else begin
{Copy element to output}
StoreElement(MergePtrs[NextElementIndex]);
if SortStatus <> 0 then
Done := True
else
{Get the next element from its merge stream}
GetMergeElementPtr(NextElementIndex);
end;
until Done;
{Flush and close the output file}
if SortStatus = 0 then
FlushOutBuffer;
TempStatus := CloseFile(OutFile);
if SortStatus = 0 then
SortStatus := TempStatus;
end;
procedure PrimaryMerge;
{-Merge until there are no more than MergeOrder merge files left}
begin
OutSelector := Selectors[MergeOrder];
while (SortStatus = 0) and (MergeFileCount-MergeFileMerged > MergeOrder) do begin
{Open next group of MergeOrder files}
OpenMergeFiles;
if SortStatus = 0 then begin
{Create new output file}
CreateNewMergeFile(OutFile);
if SortStatus = 0 then begin
{Merge these files into the output}
OutBytesUsed := 0;
MergeFileGroup;
end;
end;
end;
end;
procedure DeleteRemainingFiles;
{-Delete any remaining merge files. Needed only in case of error}
var
TempStatus : Word;
I : Word;
FName : PathArray;
begin
for I := MergeFileMerged+1 to MergeFileCount do
TempStatus := DeleteFile(MergeNameF(FName, I));
end;
{$IFDEF Windows}
procedure AHIncr; far; external 'KERNEL' index 114;
{-Magic routine for getting the constant to add to scan >64K blocks}
{$ENDIF}
function ValidateInput(RecLen : Word) : Word;
{-Validate the input parameters}
begin
{Validate SelectorInc (8 assumed throughout)}
{$IFDEF DPMI}
if SelectorInc <> 8 then begin
ValidateInput := 204;
Exit;
end;
{$ENDIF}
{$IFDEF Windows}
if Ofs(AHIncr) <> 8 then begin
ValidateInput := 204;
Exit;
end;
{$ENDIF}
if RecLen = 0 then begin
ValidateInput := 106;
Exit;
end;
ValidateInput := 0;
end;
procedure FreeAllHandles;
{-Free all allocated memory (in handle format)}
var
SelNum : Word;
begin
if SelectorCount > 0 then
for SelNum := 0 to SelectorCount-1 do
GlobalFree(Selectors[SelNum]);
end;
function HandlesToSelectors : Word;
{-Convert handles to selectors}
var
SelNum : Word;
SelectorP : Pointer;
TempSelectors : SelectorArray;
begin
{$IFDEF Windows}
for SelNum := 0 to SelectorCount-1 do begin
SelectorP := GlobalLock(Selectors[SelNum]);
if (SelectorP = nil) or (OS(SelectorP).O <> 0) then begin
FreeAllHandles;
HandlesToSelectors := 204;
Exit;
end;
TempSelectors[SelNum] := OS(SelectorP).S;
end;
{All succeeded}
move(TempSelectors, Selectors, SelectorCount*SizeOf(Word));
{$ENDIF}
HandlesToSelectors := 0;
end;
procedure SelectorsToHandles;
var
Handle : THandle;
SelNum : Word;
begin
{$IFDEF Windows}
for SelNum := 0 to SelectorCount-1 do begin
Handle := Selectors[SelNum];
GlobalUnlock(Handle);
Selectors[SelNum] := GlobalHandle(Handle);
end;
{$ENDIF}
end;
procedure GetMaxRecsPerSel(RecLen : Word);
{-Compute maximum RecsPerSel and RecsShr for given RecLen}
var
R : LongInt;
begin
R := 1;
RecsShr := 0;
while R*RecLen < 65536 do begin
R := R shl 1;
inc(RecsShr);
end;
if RecsShr > 0 then begin
R := R shr 1;
dec(RecsShr);
end;
RecsPerSel := R;
end;
function GetHandles(RecLen : Word; MaxHeapToUse : LongInt) : Word;
{-Compute segment sizes and allocate memory}
var
Handle : THandle;
InitAvail : LongInt;
SegmentSize : Word;
TooMuchHeapUsed : WordBool;
begin
{Swap elements or pointers?}
SwapPointers := (RecLen >= SwapThreshold) and
(RecLen <= 65535-SizeOf(Pointer));
{Adjust for pointer swapping}
RecordLen := RecLen;
if SwapPointers then begin
{Allocate an extra pointer for each record and swap just the pointers}
RecordLenAlloc := RecordLen+SizeOf(Pointer);
ElementPtrF := ElementPtrIndirect;
SwapElementP := SwapElementPtrs;
end else begin
RecordLenAlloc := RecordLen;
ElementPtrF := ElementPtrDirect;
SwapElementP := SwapElementsDirect;
end;
{Compute largest power-of-two number of recs that fit into 64K}
GetMaxRecsPerSel(RecordLenAlloc);
{Search for valid combinations of selectors}
repeat
{Allocate as many handles as possible in memory given}
SelectorCount := 0;
InitAvail := MemAvail;
repeat
{Allocate next handle}
Handle := GlobalAlloc(gmem_Moveable, RecsPerSel*RecordLenAlloc);
Selectors[SelectorCount] := Handle;
inc(SelectorCount);
TooMuchHeapUsed := (InitAvail-MemAvail > MaxHeapToUse);
until (SelectorCount = MaxSelectors) or (Handle = 0) or TooMuchHeapUsed;
if TooMuchHeapUsed then begin
{Deallocate last handle to keep within heap quota}
Handle := GlobalFree(Handle);
dec(SelectorCount);
{If we fail, it's because MaxHeapToUse was too small}
GetHandles := 106;
end else if Handle = 0 then begin
{Last handle wasn't allocated}
dec(SelectorCount);
{If we fail, it's because there was insufficient heap space}
GetHandles := 8;
end;
if SelectorCount < MergeOrder+1 then begin
{Not enough selectors, cut segment size in two}
FreeAllHandles;
RecsPerSel := RecsPerSel shr 1;
dec(RecsShr);
end;
until (SelectorCount >= MergeOrder+1) or (RecsPerSel = 0);
if RecsPerSel = 0 then
{No way to get enough buffers}
Exit;
RecsMask := RecsPerSel-1;
SegmentSize := RecsPerSel*RecordLenAlloc;
MergeBufSize := (SegmentSize div RecordLen)*RecordLen;
if SwapPointers then begin
{Last segment reserved for sorted run output buffer}
DSelectorCount := SelectorCount-1;
AllocatedRecs := LongInt(RecsPerSel)*DSelectorCount;
PivotPtr := ElementPtrDirect(AllocatedRecs-1);
inc(OS(PivotPtr).O, SizeOf(Pointer));
RunCapacity := AllocatedRecs-1;
end else begin
DSelectorCount := SelectorCount;
AllocatedRecs := LongInt(RecsPerSel)*DSelectorCount;
PivotPtr := ElementPtrDirect(AllocatedRecs-1);
SwapPtr := ElementPtrDirect(AllocatedRecs-2);
RunCapacity := AllocatedRecs-2;
end;
if RunCapacity < MinRecsPerRun then begin
{No way to get enough memory in enough buffers}
FreeAllHandles;
Exit;
end;
GetHandles := 0;
end;
function MergeSort(MaxHeapToUse : LongInt;
RecLen : Word;
SendToSortEngine : ElementIOProc;
Less : ElementCompareFunc;
GetFromSortEngine : ElementIOProc;
MergeName : MergeNameFunc) : Word;
begin
{Validate input parameters}
SortStatus := ValidateInput(RecLen);
{Compute selector sizes and allocate buffers}
if SortStatus = 0 then
SortStatus := GetHandles(RecLen, MaxHeapToUse);
{Convert handles to selectors}
if SortStatus = 0 then
SortStatus := HandlesToSelectors;
{Get out if any error occurred}
if SortStatus <> 0 then begin
MergeSort := SortStatus;
Exit;
end;
{Copy parameters to global variables and initialize other globals}
LessF := Less;
MergeNameF := MergeName;
RunCount := 0;
TotalCount := 0;
MergeFileCount := 0;
MergeFileMerged := 0;
{Get all the elements from the user}
SendToSortEngine;
Inc(TotalCount, RunCount);
if TotalCount = 0 then
SortStatus := 213;
if SortStatus = 0 then
if RunCount > 0 then begin
{Sort the last run buffer}
QuickSort(0, RunCount-1);
if MergeFileCount > 0 then
{There's already a merge file, create another}
StoreNewMergeFile;
end;
if SortStatus = 0 then
if MergeFileCount > 0 then begin
{Perform primary merging}
PrimaryMerge;
if SortStatus = 0 then
{Open the last group of files}
OpenMergeFiles;
end else
{Prepare to return elements from run buffer}
RunElement := 0;
if SortStatus = 0 then
{Pass elements back to the user}
GetFromSortEngine;
{Assure all merge files are gone}
DeleteRemainingFiles;
{Free global data}
SelectorsToHandles;
FreeAllHandles;
{Return status}
MergeSort := SortStatus;
end;
function PutElement(var X) : Boolean;
var
SwapPtr : PointerPtr;
DataPtr : Pointer;
begin
if SortStatus <> 0 then begin
PutElement := False;
Exit;
end;
if RunCount >= RunCapacity then begin
{Sort run buffer}
QuickSort(0, RunCount-1);
{Store to merge file}
StoreNewMergeFile;
if SortStatus <> 0 then begin
{File operation failed}
PutElement := False;
Exit;
end;
Inc(TotalCount, RunCount);
RunCount := 0;
end;
{Store the element in the run buffer}
if SwapPointers then begin
SwapPtr := ElementPtrDirect(RunCount);
DataPtr := Ptr(OS(SwapPtr).S, OS(SwapPtr).O+SizeOf(Pointer));
SwapPtr^ := DataPtr;
end else
DataPtr := ElementPtrDirect(RunCount);
MoveElement(@X, DataPtr);
Inc(RunCount);
PutElement := True;
end;
function GetElement(var X) : Boolean;
var
NextElementIndex : Word;
begin
if SortStatus <> 0 then
GetElement := False
else if MergeFileCount = 0 then begin
{No merging required}
if RunElement >= RunCount then
{No more elements}
GetElement := False
else begin
MoveElement(ElementPtrF(RunElement), @X);
inc(RunElement);
GetElement := True;
end;
end else begin
{Get next merge element}
NextElementIndex := GetNextElementIndex;
if NextElementIndex = 0 then
{No more elements or error}
GetElement := False
else begin
{Return the element}
MoveElement(MergePtrs[NextElementIndex], @X);
{Get pointer to next element in the stream just used}
GetMergeElementPtr(NextElementIndex);
GetElement := True;
end;
end;
end;
function DefaultMergeName(Dest : PChar; MergeNum : Word) : PChar;
var
S : array[0..5] of Char;
begin
Str(MergeNum, S);
DefaultMergeName := StrCat(StrCat(StrCopy(Dest, 'SOR'), S), '.TMP');
end;
procedure AbortSort;
begin
SortStatus := 1;
end;
function OptimumHeapToUse(RecLen : Word; NumRecs : LongInt) : LongInt;
begin
{Swap elements or pointers?}
SwapPointers := (RecLen >= SwapThreshold) and
(RecLen <= 65535-SizeOf(Pointer));
if SwapPointers then
inc(RecLen, SizeOf(Pointer))
else
{Account for swap element}
inc(NumRecs);
{Account for pivot element}
inc(NumRecs);
{Compute largest power-of-two number of recs that fit into 64K}
GetMaxRecsPerSel(RecLen);
{Compute number of selectors}
repeat
SelectorCount := NumRecs div RecsPerSel;
if NumRecs mod RecsPerSel <> 0 then
inc(SelectorCount);
if SwapPointers then
{Last selector used for run output buffer when swapping pointers}
inc(SelectorCount);
if SelectorCount < MergeOrder+1 then
RecsPerSel := RecsPerSel shr 1;
until (SelectorCount >= MergeOrder+1) or (RecsPerSel = 0);
if RecsPerSel = 0 then
OptimumHeapToUse := -1
else begin
if SwapPointers then
{Last segment reserved for merge output buffer}
inc(SelectorCount);
{Assume 32 byte overhead per selector and 2048 byte fixed overhead}
OptimumHeapToUse := 2048+
SelectorCount*(LongInt(RecsPerSel)*RecLen+32);
end;
end;
function MinimumHeapToUse(RecLen : Word) : LongInt;
var
MinHeapUsed : LongInt;
HeapToUse : LongInt;
begin
{Swap elements or pointers?}
SwapPointers := (RecLen >= SwapThreshold) and
(RecLen <= 65535-SizeOf(Pointer));
if SwapPointers then
inc(RecLen, SizeOf(Pointer));
{Compute largest power-of-two number of recs that fit into 64K}
GetMaxRecsPerSel(RecLen);
{Try all valid RecsPerSel}
MinHeapUsed := MaxLongInt;
repeat
{Try minimum number of selectors}
SelectorCount := MergeOrder+1;
repeat
AllocatedRecs := LongInt(RecsPerSel)*SelectorCount;
if SwapPointers then
RunCapacity := AllocatedRecs-RecsPerSel-1
else
RunCapacity := AllocatedRecs-2;
if RunCapacity < MinRecsPerRun then
inc(SelectorCount);
until RunCapacity >= MinRecsPerRun;
HeapToUse := 2048+SelectorCount*(LongInt(RecsPerSel)*RecLen+32);
if HeapToUse < MinHeapUsed then
MinHeapUsed := HeapToUse;
RecsPerSel := RecsPerSel shr 1;
until RecsPerSel = 0;
MinimumHeapToUse := MinHeapUsed;
end;
procedure MergeInfo(MaxHeapToUse : LongInt;
RecLen : Word;
NumRecs : LongInt;
var MI : MergeInfoRec);
type
MergeFileSizeArray = array[1..16383] of LongInt;
var
InitAvail : LongInt;
RecordsLeft : LongInt;
RecordsInFile : LongInt;
DiskSpace : LongInt;
OutputSpace : LongInt;
PeakDiskSpace : LongInt;
MFileCount : LongInt;
RecsNeeded : LongInt;
SizeBufSize : Word;
MergeFileSizeP : ^MergeFileSizeArray;
begin
{Set defaults for the MergeInfoRec}
FillChar(MI, SizeOf(MergeInfoRec), 0);
{Validate input parameters}
SortStatus := ValidateInput(RecLen);
if SortStatus = 0 then
if NumRecs = 0 then
SortStatus := 213;
{Compute selector sizes and allocate buffers}
if SortStatus = 0 then begin
InitAvail := MemAvail;
SortStatus := GetHandles(RecLen, MaxHeapToUse);
end;
{Get out if sort is predicted to fail}
if SortStatus <> 0 then begin
MI.SortStatus := SortStatus;
Exit;
end;
{Compute amount of memory used while getting handles}
dec(InitAvail, MemAvail);
MI.HeapUsed := InitAvail;
{Deallocate the memory allocated by GetHandles}
FreeAllHandles;
RecsNeeded := NumRecs+1;
if not SwapPointers then
inc(RecsNeeded);
if DSelectorCount*LongInt(RecsPerSel) >= RecsNeeded then begin
{All the records fit into memory}
MI.SelectorCount := SelectorCount;
MI.RecsPerSel := RecsPerSel;
Exit;
end;
{Store the information we already know}
MI.SelectorCount := SelectorCount;
MI.RecsPerSel := RecsPerSel;
{Compute initial number of merge files and disk space}
MFileCount := NumRecs div RunCapacity;
if NumRecs mod RunCapacity <> 0 then
inc(MFileCount);
if MFileCount > 65535 then begin
MI.SortStatus := 214;
Exit;
end;
MergeFileCount := MFileCount;
DiskSpace := NumRecs*RecordLen;
{At least one merge phase required}
MI.MergePhases := 1;
if MergeFileCount <= MergeOrder then begin
{Only one merge phase, direct to user}
MI.MergeFiles := MergeFileCount;
MI.MergeHandles := MergeFileCount;
MI.MaxDiskSpace := DiskSpace;
Exit;
end;
{Compute total number of merge files and merge phases}
MergeFileMerged := 0;
while MergeFileCount-MergeFileMerged > MergeOrder do begin
inc(MI.MergePhases);
MergeOpenCount := 0;
while (MergeOpenCount < MergeOrder) and (MergeFileMerged < MergeFileCount) do begin
inc(MergeOpenCount);
inc(MergeFileMerged);
end;
inc(MergeFileCount);
end;
{Store the information we already know}
MI.MergeFiles := MergeFileCount;
MI.MergeHandles := MergeOrder+1; {MergeOrder input files, 1 output file}
{Determine whether the disk space analysis can proceed}
SizeBufSize := MergeFileCount*SizeOf(LongInt);
if (MergeFileCount > 16383) or (MaxAvail < SizeBufSize) then begin
MI.MaxDiskSpace := -1;
Exit;
end;
{Allocate file size array}
GetMem(MergeFileSizeP, SizeBufSize);
{Compute size of initial merge files}
RecordsLeft := NumRecs;
MergeFileCount := 0;
while RecordsLeft > 0 do begin
inc(MergeFileCount);
if RecordsLeft >= RunCapacity then
RecordsInFile := RunCapacity
else
RecordsInFile := RecordsLeft;
MergeFileSizeP^[MergeFileCount] := RecordsInFile*RecordLen;
dec(RecordsLeft, RecordsInFile);
end;
{Carry sizes forward to get disk space used}
PeakDiskSpace := DiskSpace;
MergeFileMerged := 0;
while MergeFileCount-MergeFileMerged > MergeOrder do begin
MergeOpenCount := 0;
OutputSpace := 0;
while (MergeOpenCount < MergeOrder) and (MergeFileMerged < MergeFileCount) do begin
inc(MergeOpenCount);
inc(MergeFileMerged);
inc(OutputSpace, MergeFileSizeP^[MergeFileMerged]);
end;
inc(MergeFileCount);
{Save size of output file}
MergeFileSizeP^[MergeFileCount] := OutputSpace;
{Output file and input files coexist temporarily}
inc(DiskSpace, OutputSpace);
{Store new peak disk space}
if DiskSpace > PeakDiskSpace then
PeakDiskSpace := DiskSpace;
{Account for deleting input files}
dec(DiskSpace, OutputSpace);
end;
MI.MaxDiskSpace := PeakDiskSpace;
FreeMem(MergeFileSizeP, SizeBufSize);
end;
end.